home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 February: Tool Chest / Apple Developer CD Series Tool Chest February 1996 (Apple Computer)(1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / choose-folder-dialog / choose-folder-dialog.lisp next >
Encoding:
Text File  |  1994-06-16  |  13.2 KB  |  238 lines  |  [TEXT/CCL2]
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;;;
  3. ;;;; choose-folder-dialog
  4. ;;;;
  5. ;;;; Dan S. Camper
  6. ;;;; June, 1994
  7. ;;;;
  8. ;;;; This module is intended to offer a replacement to MCL's #'choose-directory-dialog function.
  9. ;;;; The interface is a bit better, or at least more like the interface used in other Mac
  10. ;;;; applications. System 7 is required for this to work.  You'll also need the resources found
  11. ;;;; in the included ResEdit document.
  12. ;;;; 
  13. ;;;; This code was modeled from Greg Robbins' "StandardGetFolder", written in both Think C and
  14. ;;;; Pascal and distributed on Apple's ETO CD-ROM as a DTS Snippet.
  15. ;;;;
  16. ;;;; Usage:
  17. ;;;;
  18. ;;;;    #'choose-folder-dialog       The function itself; it accepts the following keyed parameters:
  19. ;;;;          button-string          A "prefix" to the select button on the dialog; defaults to
  20. ;;;;                                 "Select" (eg, "Select <FolderName>")
  21. ;;;;          position               Position of dialog; defaults to centered on the primary screen
  22. ;;;;          select-key             Command key equivalent for selecting the directory; must be
  23. ;;;;                                 a character.  The default is nil.
  24. ;;;;          resource-path          If a file pathname is specified then the file will should
  25. ;;;;                                 contain the custom DLOG and DITL resources needed for this
  26. ;;;;                                 dialog.  The default is nil, which indicates that the current
  27. ;;;;                                 application should have these resources included.  This is a
  28. ;;;;                                 handy parameter to have during development, if you don't want
  29. ;;;;                                 to load MCL with resources it doesn't usually use.
  30. ;;;;          resource-id            The ID number associated with the DLOG and DTIL resources
  31. ;;;;                                 used in this custom dialog.  The default is 128.
  32. ;;;;
  33. ;;;; Function returns:
  34. ;;;;
  35. ;;;;    If successful, the function returns a Lisp pathname (unlike #'choose-directory-dialog, which
  36. ;;;;    returns a string).  If the user clicks the cancel button then the function will execute
  37. ;;;;    'throw-cancel (which you can trap with 'catch-cancel).  If an error occurs while resolving a
  38. ;;;;    supposedly-valid user selection the function returns nil.
  39. ;;;;
  40. (in-package :ccl)
  41.  
  42. (eval-when (:compile-toplevel :load-toplevel :execute)
  43.   (require :resources))
  44.  
  45. (export '(choose-folder-dialog))
  46.  
  47. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  48.  
  49. (defconstant $kGFSelectItem 10 "Select button")
  50. (defconstant $kDefaultResourceID 128)
  51.  
  52. (defvar *get-folder-dialog-select-button* nil)
  53. (defvar *get-folder-dialog-desktop-name* "Desktop" "Displayed name of desktop folder")
  54. (defvar *get-folder-default-button-string* "Select" "Prefix for select button")
  55. (defvar *get-folder-select-char* nil "Command key equivalent for selecting the directory; must be a character")
  56.  
  57. (defrecord (CustomGetFileDataRec :pointer)
  58.   (SFRPtr :StandardFileReply)
  59.   (oldSelectionFSSpec :FSSpec))
  60.  
  61. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  62.  
  63. (defun choose-folder-dialog (&key (button-string *get-folder-default-button-string*)
  64.                                   (position #@(-1 -1))
  65.                                   (select-key *get-folder-select-char*)
  66.                                   (resource-path nil)
  67.                                   (resource-id $kDefaultResourceID))
  68.   (let ((*get-folder-dialog-select-button* button-string)
  69.         (*get-folder-select-char* select-key))
  70.     (standard-get-folder position resource-id resource-path)))
  71.  
  72. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  73.  
  74. (defun set-button-name (dialog-ptr button-id button-name quote?)
  75.   (rlet ((button-type :signed-integer)
  76.          (button-rect :rect)
  77.          (button-handle :handle))
  78.     (with-pstrs ((select-label-ptr *get-folder-dialog-select-button*)
  79.                  (quotes-and-space-ptr (format nil "~A ~A" #\“ #\”))
  80.                  (space-ptr " "))
  81.       (#_GetDItem dialog-ptr button-id button-type button-handle button-rect)
  82.       (let* ((text-width (- (pref button-rect :Rect.right)
  83.                             (pref button-rect :Rect.left)
  84.                             8))
  85.              (button-label (if quote?
  86.                              (truncate-string (format nil "~A ~A~A~A" *get-folder-dialog-select-button* #\“ button-name #\”) text-width)
  87.                              (truncate-string (format nil "~A ~A" *get-folder-dialog-select-button* button-name ) text-width))))
  88.         (with-pstrs ((button-label-ptr button-label))
  89.           (#_SetCTitle (%get-ptr button-handle) button-label-ptr)))
  90.       (#_ValidRect button-rect))))
  91.  
  92. (defun truncate-string (string width &optional (font '("Chicago" 12 :plain :srcor)))
  93.   (let ((ellipsis "…")
  94.         (new-string string))
  95.     (when (and (stringp string)
  96.                (integerp width)
  97.                (plusp width)
  98.                (> (string-width string font) width)
  99.                (< (string-width ellipsis font) width))
  100.       (let* ((mid (floor (length string) 2))
  101.              (prefix (subseq string 0 mid))
  102.              (suffix (subseq string (1+ mid) (length string)))
  103.              (toggle nil))
  104.         (loop while (and (> (string-width (format nil "~A~A~A" prefix ellipsis suffix) font) width)
  105.                          (not (equalp prefix ""))
  106.                          (not (equalp suffix "")))
  107.               do (if toggle
  108.                    (setf prefix (subseq prefix 0 (1- (length prefix))))
  109.                    (setf suffix (subseq suffix 1 (length suffix))))
  110.               do (setf toggle (not toggle)))
  111.         (unless (or (equalp prefix "") (equalp suffix ""))
  112.           (setf new-string (format nil "~A~A~A" prefix ellipsis suffix)))))
  113.     new-string))
  114.  
  115. (defun same-fsspec (fsspec-rec1 fsspec-rec2)
  116.   (and (= (pref fsspec-rec1 :FSSpec.vRefNum) (pref fsspec-rec2 :FSSpec.vRefNum))
  117.        (= (pref fsspec-rec1 :FSSpec.parID) (pref fsspec-rec2 :FSSpec.parID))
  118.        (equalp (pref fsspec-rec1 :FSSpec.name) (pref fsspec-rec2 :FSSpec.name))))
  119.  
  120. (defpascal MyModalDialogFilter (:ptr theDlgPtr :ptr myEvtRec :ptr item :ptr myDataPtr
  121.                                      :word)
  122.   (declare (ignore myDataPtr))
  123.   (let ((return-value #$false))
  124.     (when (and *get-folder-select-char*
  125.                (equal (%get-ostype theDlgPtr #.(field-info :WindowRecord 'RefCon)) #$sfMainDialogRefCon)
  126.                (= (pref myEvtRec :EventRecord.What) #$keyDown)
  127.                (not (zerop (logand (pref myEvtRec :EventRecord.Modifiers) #$cmdKey)))
  128.                (equalp (code-char (logand (pref myEvtRec :EventRecord.Message) #$CharCodeMask)) *get-folder-select-char*))
  129.       (%put-word item $kGFSelectItem)
  130.       (setf return-value #$true)
  131.       (rlet ((button-type :signed-integer)
  132.              (button-rect :rect)
  133.              (final-ticks :signed-long)
  134.              (button-handle :handle))
  135.         (#_GetDItem theDlgPtr $kGFSelectItem button-type button-handle button-rect)
  136.         (#_HiliteControl (%get-ptr button-handle) #$inButton)
  137.         (#_Delay 8 final-ticks)
  138.         (#_HiliteControl (%get-ptr button-handle) 0)
  139.         ))
  140.     return-value))
  141.  
  142. (defpascal MyCustomFileFilter (:ptr myCInfoPBPtr :ptr myDataPtr
  143.                                     :word)
  144.   (declare (ignore myDataPtr))
  145.   (if (logbitp 4 (pref myCInfoPBPtr :CInfoPBRec.ioFlAttrib))
  146.     #$false
  147.     #$true))
  148.  
  149. (defpascal MyDialogHook (:word item :ptr theDialogPtr :ptr customDataPtr
  150.                                :word)
  151.   (when (equal (%get-ostype theDialogPtr #.(field-info :WindowRecord 'RefCon)) #$sfMainDialogRefCon)
  152.     (rlet ((desktopVRefNum :integer)
  153.            (desktopDirID :longint)
  154.            (tempFSSpec :FSSpec))
  155.       (if (= item $kGFSelectItem)
  156.         (setf item #$sfItemOpenButton))
  157.       (#_FindFolder (pref customDataPtr :CustomGetFileDataRec.SFRPtr.sfFile.vRefNum) #$kDesktopFolderType #$kDontCreateFolder desktopVRefNum desktopDirID)
  158.       (when (or (not (same-fsspec (rref customDataPtr :CustomGetFileDataRec.oldSelectionFSSpec) (rref customDataPtr :CustomGetFileDataRec.SFRPtr.sfFile)))
  159.                 (= item #$sfHookFirstCall)
  160.                 (= item #$sfHookChangeSelection)
  161.                 (= item #$sfHookRebuildList))
  162.         (if (not (equalp (pref customDataPtr :CustomGetFileDataRec.SFRPtr.sfFile.name) ""))
  163.           (set-button-name theDialogPtr $kGFSelectItem (pref customDataPtr :CustomGetFileDataRec.SFRPtr.sfFile.name) t)
  164.           (progn
  165.             (if (and (= (pref customDataPtr :CustomGetFileDataRec.SFRPtr.sfFile.vRefNum) (%get-word desktopVRefNum))
  166.                      (= (pref customDataPtr :CustomGetFileDataRec.SFRPtr.sfFile.ParID) (%get-long desktopDirID)))
  167.               (set-button-name theDialogPtr $kGFSelectItem *get-folder-dialog-desktop-name* nil)
  168.               (progn
  169.                 (rlet ((short-str :Str63))
  170.                   (%put-string short-str "")
  171.                   (#_FSMakeFSSpec (pref customDataPtr :CustomGetFileDataRec.SFRPtr.sfFile.vRefNum) (pref customDataPtr :CustomGetFileDataRec.SFRPtr.sfFile.ParID) short-str tempFSSpec)
  172.                   (set-button-name theDialogPtr $kGFSelectItem (pref tempFSSpec :FSSpec.name) t)))))))
  173.       (setf (pref customDataPtr :CustomGetFileDataRec.oldSelectionFSSpec.vRefNum) (pref customDataPtr :CustomGetFileDataRec.SFRPtr.sfFile.vRefNum)
  174.             (pref customDataPtr :CustomGetFileDataRec.oldSelectionFSSpec.parID) (pref customDataPtr :CustomGetFileDataRec.SFRPtr.sfFile.parID)
  175.             (pref customDataPtr :CustomGetFileDataRec.oldSelectionFSSpec.name) (pref customDataPtr :CustomGetFileDataRec.SFRPtr.sfFile.name))))
  176.   item)
  177.  
  178. (defun standard-get-folder (position res-id res-path)
  179.   (rlet ((mySFTypeList :SFTypeList)
  180.          (myData :CustomGetFileDataRec)
  181.          (folderFlag :boolean)
  182.          (wasAliasedFlag :boolean))
  183.     ; Make sure #_CustomGetFile is available
  184.     (when (logbitp #$gestaltStandardFile58 (or (gestalt #$gestaltStandardFileAttr) 0))
  185.       (setf (pref myData :StandardFileReply.sfFile.name) ""
  186.             (pref myData :StandardFileReply.sfFile.vRefNum) 0
  187.             (pref myData :StandardFileReply.sfFile.parID) 0)
  188.       (if (pathnamep res-path)
  189.         (progn
  190.           (with-open-resource-file (ref res-path)
  191.             (#_CustomGetFile MyCustomFileFilter 0 mySFTypeList myData res-id position MyDialogHook MyModalDialogFilter (%null-ptr) (%null-ptr) myData)))
  192.         (#_CustomGetFile MyCustomFileFilter 0 mySFTypeList myData res-id position MyDialogHook MyModalDialogFilter (%null-ptr) (%null-ptr) myData))
  193.       (when (pref myData :StandardFileReply.sfGood)
  194.         (when (equalp (pref myData :StandardFileReply.sfFile.name) "")
  195.           ; Nothing selected, get parent folder
  196.           (rlet ((short-str :Str63))
  197.             (%put-string short-str "")
  198.             (let ((err (#_FSMakeFSSpec (pref myData :StandardFileReply.sfFile.vRefNum) (pref myData :StandardFileReply.sfFile.parID) short-str (rref myData :StandardFileReply.sfFile))))
  199.               (setf (pref myData :StandardFileReply.sfGood) (eql err #$noErr)))))
  200.         (when (not (equalp (pref myData :StandardFileReply.sfFile.name) ""))
  201.           ; If we don't have a name at this point then there's an error
  202.           (when (= (pref myData :StandardFileReply.sfFile.parID) 1)
  203.             (setf (pref myData :StandardFileReply.sfIsVolume) t
  204.                   (pref myData :StandardFileReply.sfIsFolder) t))
  205.           (let ((alias-err (#_ResolveAliasFile (rref myData :StandardFileReply.sfFile) t folderFlag wasAliasedFlag)))
  206.             (if (neq alias-err #$noErr)
  207.               (setf (pref myData :StandardFileReply.sfGood) nil)
  208.               (if (= (%get-byte folderFlag) #$true)
  209.                 (setf (pref myData :StandardFileReply.sfIsFolder) t))))))
  210.       (if (pref myData :StandardFileReply.sfGood)
  211.         ; Build up a valid pathname.
  212.         (let ((final-path nil)
  213.               (keep-looping t)
  214.               (err #$noErr))
  215.           (rlet ((cpb :CInfoPBRec))
  216.             (with-returned-pstrs ((pname (pref myData :StandardFileReply.sfFile.name)))
  217.               (setf (rref cpb :CInfoPBRec.ioVRefNum) (pref myData :StandardFileReply.sfFile.vRefNum)
  218.                     (rref cpb :CinfoPBRec.ioNamePtr) pname
  219.                     (rref cpb :CInfoPBRec.ioDrParID) 0
  220.                     (rref cpb :CInfoPBRec.ioDrDirID) (pref myData :StandardFileReply.sfFile.parID)
  221.                     (rref cpb :CInfoPBRec.ioFDirIndex) 0)
  222.               (loop while keep-looping
  223.                     do (setf err (#_PBGetCatInfo cpb))
  224.                     do (if (eq err #$noErr)
  225.                          (progn
  226.                            (push (%get-string (rref cpb :CInfoPBRec.ioNamePtr)) final-path)
  227.                            (setf keep-looping (not (equal (rref cpb :CInfoPBRec.ioDrDirID) #$fsRtDirID))
  228.                                  (rref cpb :CInfoPBRec.ioDrDirID) (rref cpb :CInfoPBRec.ioDrParID)
  229.                                  (rref cpb :CInfoPBRec.ioFDirIndex) -1))
  230.                          (setf keep-looping nil)))))
  231.           (when (eql err #$noErr)
  232.             (push :absolute final-path)
  233.             (make-pathname :directory final-path)))
  234.         (throw-cancel)))))
  235.  
  236. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  237.  
  238. (provide :choose-folder-dialog)